home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DBASE_UT / TPDB335 / TPDBDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-26  |  9KB  |  341 lines
  1. unit TPDBDate;
  2.                            (***********************************)
  3.                            (*               TPDB              *)
  4.                            (***********************************)
  5.                            (*         Object -Oriented        *)
  6.                            (*    Borland/Turbo Pascal Units   *)
  7.                            (*    for Accessing dBASE III      *)
  8.                            (*             files.              *)
  9.                            (*      Copyright 1988 - 1993      *)
  10.                            (*          Brian Corll            *)
  11.                            (*       All Rights Reserved       *)
  12.                            (***********************************)
  13.                            (*            FREEWARE             *)
  14.                            (***********************************)
  15.                            (*     dBASE is a registered       *)
  16.                            (* trademark of Borland Int. Inc.  *)
  17.                            (*   Version 3.35  November, 1993  *)
  18.                            (***********************************)
  19.                            (*   Portions Copyright 1984,1991  *)
  20.                            (*    Borland International Corp.  *)
  21.                            (***********************************)
  22.  
  23. interface
  24.  
  25. uses
  26.     {$IFDEF WINDOWS}
  27.     WINDOS;
  28.     {$ELSE}
  29.     Dos;
  30.     {$ENDIF}
  31.  
  32. type
  33.     DayStr = string [9];
  34.     DateType = word;
  35.     DateStr = string [8];
  36.     TimeStr = string [13];
  37.     Str9 = string [9];
  38.  
  39. function CalcDate(InDate: DateStr; Days, Months, Years: integer): DateStr;
  40. (* Add or subtract days,months, or years from two dates. *)
  41.  
  42. function CDOW(InDate: DateStr): DayStr;
  43. (* Returns character day of week - i.e. 'Monday','Tuesday',etc. *)
  44.  
  45. function CMonth(InDate: DateStr): Str9;
  46. (* Returns character month - i.e. 'March' *)
  47.  
  48. function CompDates(Date1, Date2: DateStr): word;
  49. (* Compares two dates and calculates the number of days between them. *)
  50.  
  51. function CTOD(InDate: DateStr): DateType;
  52. (* Converts a .DBF compatible date field to a word date type. *)
  53.  
  54. function DTOC(Julian: DateType): DateStr;
  55. (* Converts a word date type to a string compatible with .DBF date fields. *)
  56.  
  57.  
  58. function Mon(InDate: DateStr): byte;
  59. (* Returns numeric value for the month in a date. *)
  60.  
  61. function TimeNow: TimeStr;
  62. (* Returns current time in formatted string. *)
  63.  
  64. function Today: DateStr;
  65. (* Returns current date in .DBF date field compatible format. *)
  66.  
  67. function ValidDate(InDate: DateStr): boolean;
  68. (* Checks whether a date is valid. *)
  69.  
  70. function FormDate(InDate: DateStr): string;
  71. (* Formats a date as 'MM/DD/YY' *)
  72.  
  73.  
  74.  
  75.  
  76. implementation
  77.  
  78. const
  79.     Months: array [1..12] of Str9 = ('January  ', 'February ', 'March    ', 'April    ', 'May      ', 'June     ',
  80.             'July     ', 'August   ', 'September', 'October  ', 'November ', 'December ');
  81.  
  82. var
  83.     Temp, Month, Day, Year, ErrCode: integer;
  84.     MM, DD: string [2];
  85.     YY: string [4];
  86.  
  87.  
  88. function CDOW(InDate: DateStr): DayStr;
  89. (* Returns the name of the day of the week represented by
  90.    a date. *)
  91.  
  92. var
  93.     DayOfWeek, DOW: integer;
  94.  
  95. begin
  96.     YY := Copy(InDate, 1, 4);
  97.     MM := Copy(InDate, 5, 2);
  98.     DD := Copy(InDate, 7, 2);
  99.     Val(MM, Month, ErrCode);
  100.     Val(DD, Day, ErrCode);
  101.     Val(YY, Year, ErrCode);
  102.     if month <= 2 then begin
  103.         month := month + 12;
  104.         year := year - 1;
  105.     end;
  106.  
  107.     DayOfWeek := (Day + month * 2 + (month + 1) * 6 div 10 + year + year div 4 - year div 100 + year div 400 + 2) mod 7;
  108.  
  109.     if DayOfWeek = 0 then
  110.         DOW := 7
  111.     else
  112.         DOW := DayOfWeek;
  113.  
  114.     case DOW of
  115.         1: CDOW := 'Sunday';
  116.         2: CDOW := 'Monday';
  117.         3: CDOW := 'Tuesday';
  118.         4: CDOW := 'Wednesday';
  119.         5: CDOW := 'Thursday';
  120.         6: CDOW := 'Friday';
  121.         7: CDOW := 'Saturday';
  122.     end;
  123. end;
  124.  
  125. function CTOD(InDate: DateStr): DateType;
  126. (* Convert from a date string to a word date type. *)
  127.  
  128. var
  129.     Julian: DateType;
  130.  
  131. begin
  132.     YY := Copy(InDate, 1, 4);
  133.     MM := Copy(InDate, 5, 2);
  134.     DD := Copy(InDate, 7, 2);
  135.  
  136.     Val(YY, Year, ErrCode);
  137.     Val(MM, Month, ErrCode);
  138.     Val(DD, Day, ErrCode);
  139.  
  140.     if (Year = 1900) and (Month < 3) then
  141.         if Month = 1 then
  142.             Julian := Pred(Day)
  143.         else
  144.             Julian := Day + 30
  145.     else begin
  146.         if Month > 2 then
  147.             Dec(Month, 3)
  148.         else begin
  149.             Inc(Month, 9);
  150.             Dec(Year)
  151.         end;
  152.         Dec(Year, 1900);
  153.         Julian := (1461 * longint(Year) div 4) + ((153 * Month + 2) div 5) + Day + 58
  154.     end;
  155.     CTOD := Julian;
  156. end;
  157.  
  158. function DTOC(Julian: DateType): DateStr;
  159. (* Convert from a word date type to a date string. *)
  160.  
  161. var
  162.     LongTemp: longint;
  163.  
  164. begin
  165.     if Julian <= 58 then begin
  166.         Year := 1900;
  167.         if Julian <= 30 then begin
  168.             Month := 1;
  169.             Day := Succ(Julian)
  170.         end else begin
  171.             Month := 2;
  172.             Day := Julian - 30
  173.         end
  174.     end else begin
  175.         LongTemp := 4 * longint(Julian) - 233;
  176.         Year := LongTemp div 1461;
  177.         Temp := LongTemp mod 1461 div 4 * 5 + 2;
  178.         Month := Temp div 153;
  179.         Day := Temp mod 153 div 5 + 1;
  180.         Inc(Year, 1900);
  181.         if Month < 10 then
  182.             Inc(Month, 3)
  183.         else begin
  184.             Dec(Month, 9);
  185.             Inc(Year)
  186.         end
  187.     end;
  188.     Str(Month: 2, MM);
  189.     Str(Day: 2, DD);
  190.     Str(Year: 4, YY);
  191.     if Month < 10 then
  192.         MM := '0' + Copy(MM, 2, 1);
  193.     if Day < 10 then
  194.         DD := '0' + Copy(DD, 2, 1);;
  195.     DTOC := YY + MM + DD;
  196. end;
  197.  
  198. function ValidDate(InDate: DateStr): boolean;
  199. (* Check whether a date field contains a valid date. *)
  200.  
  201. begin
  202.     YY := Copy(InDate, 1, 4);
  203.     MM := Copy(InDate, 5, 2);
  204.     DD := Copy(InDate, 7, 2);
  205.     Val(DD, Day, ErrCode);
  206.     Val(MM, Month, ErrCode);
  207.     Val(YY, Year, ErrCode);
  208.     if (Day = 0) and (Year - 1900 = 0) and (Month = 0) then begin
  209.         ValidDate := True;
  210.         Exit;
  211.     end;
  212.     if (Day < 1) or (Year < 1900) or (Year > 2078) then
  213.         ValidDate := False
  214.     else
  215.         case Month of
  216.             1, 3, 5, 7, 8, 10, 12: ValidDate := Day <= 31;
  217.             4, 6, 9, 11: ValidDate := Day <= 30;
  218.             2: ValidDate := Day <= 28 + Ord((Year mod 4) = 0) * Ord(Year <> 1900) else ValidDate := False
  219.         end
  220. end;
  221.  
  222. function CalcDate(InDate: DateStr; Days, Months, Years: integer): DateStr;
  223. (* Add or subtract days, months , and years from a specific date string,
  224.  as stored in a .DBF record. *)
  225.  
  226. var
  227.     Julian: DateType;
  228.     TempDate: DateStr;
  229.  
  230. begin
  231.     YY := Copy(InDate, 1, 4);
  232.     MM := Copy(InDate, 5, 2);
  233.     DD := Copy(InDate, 7, 2);
  234.     Val(MM, Month, ErrCode);
  235.     Val(DD, Day, errCode);
  236.     Val(YY, Year, ErrCode);
  237.     Month := Month + Months - 1;
  238.     Year := Year + Years + (Month div 12) - Ord(Month < 0);
  239.     Month := (Month + 12000) mod 12 + 1;
  240.     Str(Month: 2, MM);
  241.     Str(Day: 2, DD);
  242.     Str(Year: 4, YY);
  243.     if Month < 10 then
  244.         MM := '0' + Copy(MM, 2, 1);
  245.     if Day < 10 then
  246.         DD := '0' + Copy(DD, 2, 1);
  247.     TempDate := YY + MM + DD;
  248.     Julian := CTOD(TempDate) + Days;
  249.     CalcDate := DTOC(Julian);
  250. end;
  251.  
  252. function CompDates(Date1, Date2: DateStr): word;
  253. (* Compare two dates and calculate the number of
  254.  days between them. *)
  255.  
  256. begin
  257.     if CTOD(Date1) > CTOD(Date2) then
  258.         CompDates := CTOD(Date1) - CTOD(Date2)
  259.     else
  260.         CompDates := CTOD(Date2) - CTOD(Date1);
  261. end;
  262.  
  263. function CMonth(InDate: DateStr): Str9;
  264. (* Returns the month name for any date. *)
  265.  
  266. begin
  267.     MM := Copy(InDate, 5, 2);
  268.     Val(MM, Month, ErrCode);
  269.     CMonth := Months[Month]
  270. end;
  271.  
  272. function TimeNow: TimeStr;
  273. (* Returns a formatted string for the current time. *)
  274.  
  275. var
  276.     Hour, Minute, Second, Sec100: word;
  277.     HH, MM, SS: string [2];
  278.     Temp: string [8];
  279.     Code: integer;
  280.  
  281. begin
  282.     GetTime(Hour, Minute, Second, Sec100);
  283.     Str(Minute, MM);
  284.     Str(Second, SS);
  285.     if Minute < 10 then
  286.         MM := '0' + MM;
  287.     if Second < 10 then
  288.         SS := '0' + SS;
  289.     if Hour > 12 then begin
  290.         Str(Hour - 12, HH);
  291.     end else
  292.         Str(Hour, HH);
  293.     if Hour >= 12 then
  294.         TimeNow := HH + ':' + MM + ':' + SS + ' p.m.'
  295.     else
  296.         TimeNow := HH + ':' + MM + ':' + SS + ' a.m.';
  297. end;
  298.  
  299. function Today: DateStr;
  300. (* Returns today's date in dBASE III date format. *)
  301.  
  302. var
  303.     mMonth, mDay, mYear, mDayOfWk: word;
  304.  
  305. begin
  306.     GetDate(mYear, mMonth, mDay, mDayOfWk);
  307.     Str(mMonth, MM);
  308.     Str(mDay, DD);
  309.     Str(mYear, YY);
  310.     if mMonth < 10 then
  311.         Insert('0', MM, 1);
  312.     if mDay < 10 then
  313.         Insert('0', DD, 1);
  314.     Today := YY + MM + DD;
  315. end;
  316.  
  317. function Mon(InDate: DateStr): byte;
  318. (* Returns number of month in a date. *)
  319.  
  320. var
  321.     Temp: byte;
  322.  
  323. begin
  324.     MM := Copy(InDate, 5, 2);
  325.     Val(MM, Temp, ErrCode);
  326.     Mon := Temp;
  327. end;
  328.  
  329. function FormDate(InDate: DateStr): string;
  330. (* Formats dBASE date field as MM/DD/YY *)
  331.  
  332. var
  333.     OutDate: string [8];
  334.  
  335. begin
  336.     OutDate := Copy(InDate, 5, 2) + '/' + Copy(InDate, 7, 2) + '/' + Copy(InDate, 3, 2);
  337.     FormDate := OutDate;
  338. end;
  339.  
  340. end.                                                        (* TPDBDate *)
  341.